home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
PowerLisp 2.01
/
PowerLisp 2.01 ƒ
/
Library
/
format.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1996-05-17
|
22KB
|
706 lines
;;;
;;; PowerLisp 2.0
;;; Copyright © 1996 Roger Corman. All rights reserved.
;;;
;;;
;;; Common Lisp 'format' function.
;;;
(in-package :common-lisp)
(provide :format)
(defun format (dest control-string &rest arguments)
(let ((return-value nil) (%debug nil))
;; check for dest equal to t or nil
(cond
((null dest)
(progn
(setf dest (make-string-output-stream))
(setf return-value dest)))
((eq dest t) (setf dest *standard-output*)))
(catch '%format-up-and-out
(%format-list dest control-string arguments))
(if return-value (get-output-stream-string return-value))))
(defun %format-list (dest control-string arguments)
;; scan control string and dispatch to output functions
(do ((index 0)
(arg-index 0)
(length (length control-string))
(atsign-modifier nil nil)
(colon-modifier nil nil)
dispatch-func
(parameters nil)
control
char)
((>= index length) arg-index)
(setf char (char control-string index))
(if (char= char #\~)
;; process directive
(progn
;; get parameters
(incf index)
(multiple-value-setq (parameters index)
(%get-params control-string index))
;; check for modifiers
(dotimes (i 2)
(if (>= index length) (return))
(setq char (char control-string index))
(if (char= char #\@)
(setq atsign-modifier t)
(if (char= char #\:)
(setq colon-modifier t)
(return)))
(incf index))
;; the next character should be the format
;; directive character
(if (>= index length)
(error "Invalid format directive: ~A" control-string))
(setq char (char control-string index))
(incf index)
(setf dispatch-func
(%get-format-dispatch-func char))
(if (null dispatch-func)
(error "Invalid format directive : ~A" control-string))
(setq control (list control-string index))
(setq arg-index
(apply dispatch-func
dest
arguments arg-index
atsign-modifier colon-modifier
control
parameters))
(setq index (cadr control)))
;; just output the character
(progn
(write-char char dest)
(incf index)))))
;;;
;;;
;;; Returns two values: the list of params found and the
;;; updated index.
;;
(defun %get-params (control-string index &aux (params nil))
(do (int
c
(length (length control-string)))
((>= index length))
(if (char= (char control-string index) #\Newline)
(return))
(multiple-value-setq (int index)
(parse-integer control-string :start index
:junk-allowed t))
(setq c (char control-string index))
(if int
(push int params)
(if (char= c #\,)
(push nil params)))
(if (char= c #\,) (incf index) (return)))
(values (nreverse params) index))
;;; Format dispatch functions take a stream, argument list,
;;; @-modifier and :-modifier arguments, followed by any passed
;;; parameters. Any passed parameters which are nil should be
;;; assumed to be requesting the default. The dispatch functions
;;; should return the remaining argument list (missing the
;;; arguments that they processed.
;;;
(defvar *format-functions* #256())
(defun %set-format-dispatch-func (char func)
(let ((index (char-code (char-upcase char))))
(setf (elt *format-functions* index) func)))
(defun %get-format-dispatch-func (char)
(let ((index (char-code (char-upcase char))))
(elt *format-functions* index)))
(%set-format-dispatch-func #\A
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional mincol colinc
minpad padchar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~AA format directive" #\~))
;; initialize defaults
(unless mincol (setq mincol 0))
(unless colinc (setq colinc 1))
(unless minpad (setq minpad 0))
(setq padchar (if padchar (int-char padchar) #\Space))
(let ((*print-escape* nil)
(arg (car args)))
(if (and (null arg) colon-modifier)
(setq arg "()"))
(if atsign-modifier
;; needto output to string to insert padding in front
(let ((s (with-output-to-string (x) (princ arg x)))
length)
(dotimes (i minpad) (write-char padchar stream))
(setq length (length s))
(incf length minpad)
(do ()
((>= length mincol))
(dotimes (i colinc) (write-char padchar stream))
(incf length colinc))
(princ s stream))
(let (length (start-pos (stream-column stream)))
(princ arg stream)
(setq length (- (stream-column stream) start-pos))
(if (< length 0) (setq length 0))
(dotimes (i minpad) (write-char padchar stream))
(incf length minpad)
(do ()
((>= length mincol))
(dotimes (i colinc) (write-char padchar stream))
(incf length colinc)))))
(1+ index)))
(%set-format-dispatch-func #\S
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional mincol colinc
minpad padchar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~AS format directive" #\~))
;; initialize defaults
(unless mincol (setq mincol 0))
(unless colinc (setq colinc 1))
(unless minpad (setq minpad 0))
(setq padchar (if padchar (int-char padchar) #\Space))
(let ((*print-escape* t)
(arg (car args)))
(if (and (null arg) colon-modifier)
(setq arg "()"))
(if atsign-modifier
;; need to output to string to insert padding in front
(let ((s (with-output-to-string (x) (prin1 arg x)))
length)
(dotimes (i minpad) (write-char padchar stream))
(setq length (length s))
(incf length minpad)
(do ()
((>= length mincol))
(dotimes (i colinc) (write-char padchar stream))
(incf length colinc))
(princ s stream))
(let (length (start-pos (stream-column stream)))
(prin1 arg stream)
(setq length (- (stream-column stream) start-pos))
(if (< length 0) (setq length 0))
(dotimes (i minpad) (write-char padchar stream))
(incf length minpad)
(do ()
((>= length mincol))
(dotimes (i colinc) (write-char padchar stream))
(incf length colinc)))))
(1+ index)))
(%set-format-dispatch-func #\D
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional mincol padchar commachar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~~D format directive"))
;; if not an integer use ~A output
(if (not (integerp (car args)))
(let ((*print-base* 10))
(return (apply (%get-format-dispatch-func #\A)
stream args atsign-modifier
colon-modifier mincol nil nil padchar))))
(%format-integer stream (car args) 10 atsign-modifier colon-modifier
mincol padchar commachar)
(1+ index)))
(%set-format-dispatch-func #\B
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional mincol padchar commachar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~AB format directive" #\~))
;; if not an integer use ~A output
(if (not (integerp (car args)))
(let ((*print-base* 2))
(return (apply (%get-format-dispatch-func #\A)
stream args atsign-modifier
colon-modifier mincol nil nil padchar))))
(%format-integer stream (car args) 2 atsign-modifier colon-modifier
mincol padchar commachar)
(1+ index)))
(%set-format-dispatch-func #\O
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional mincol padchar commachar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~AO format directive" #\~))
;; if not an integer use ~A output
(if (not (integerp (car args)))
(let ((*print-base* 8))
(return (apply (%get-format-dispatch-func #\A)
stream args atsign-modifier
colon-modifier mincol nil nil padchar))))
(%format-integer stream (car args) 8 atsign-modifier colon-modifier
mincol padchar commachar)
(1+ index)))
(%set-format-dispatch-func #\X
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional mincol padchar commachar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~AX format directive" #\~))
;; if not an integer use ~A output
(if (not (integerp (car args)))
(let ((*print-base* 16))
(return (apply (%get-format-dispatch-func #\A)
stream args atsign-modifier
colon-modifier mincol nil nil padchar))))
(%format-integer stream (car args) 16 atsign-modifier colon-modifier
mincol padchar commachar)
(1+ index)))
(%set-format-dispatch-func #\R
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional radix mincol padchar commachar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~AR format directive" #\~))
(if radix
;; if not an integer use ~A output
(progn
(if (not (integerp (car args)))
(let ((*print-base* radix))
(return (apply (%get-format-dispatch-func #\A)
args atsign-modifier
colon-modifier mincol nil nil padchar))))
(unless (and (plusp radix) (<= radix 36))
(error "Invalid radix specified: ~A" radix))
(%format-integer stream (car args) radix atsign-modifier colon-modifier
mincol padchar commachar))
(progn
(if (not (integerp (car args)))
(return (apply (%get-format-dispatch-func #\A)
args atsign-modifier
colon-modifier mincol nil nil padchar)))
(cond
((and atsign-modifier colon-modifier)
(%format-old-roman-numeral (car args) stream))
(atsign-modifier (%format-roman-numeral (car args) stream))
(colon-modifier (%format-ordinal-number (car args) stream))
(t (%format-cardinal-number (car args) stream)))))
(1+ index)))
(%set-format-dispatch-func #\~
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional num)
(unless num (setq num 1))
(dotimes (i num)
(write-char #\~ stream))
index))
(%set-format-dispatch-func #\%
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional num)
(unless num (setq num 1))
(dotimes (i num)
(write-char #\Newline stream))
index))
(%set-format-dispatch-func #\F
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional width digits scale overflow-char padchar)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~~F format directive"))
;; initialize defaults
(unless width (setq width -1))
(unless digits (setq digits 1))
(unless scale (setq scale 0))
(setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
(setq padchar (if padchar (int-char padchar) #\Space))
(print-float (car args) stream :fixed width digits
scale padchar atsign-modifier)
(1+ index)))
(%set-format-dispatch-func #\G
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional width digits exp-digits scale overflow-char padchar
exponent-char)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~~G format directive"))
;; initialize defaults
(unless width (setq width -1))
(unless digits (setq digits 1))
(unless exp-digits (setq exp-digits 2))
(unless scale (setq scale 0))
(setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
(setq padchar (if padchar (int-char padchar) #\Space))
(setq exponent-char (if exponent-char (int-char exponent-char) #\E))
(print-float (car args) stream :general width digits
scale padchar atsign-modifier)
(1+ index)))
(%set-format-dispatch-func #\E
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional width digits exp-digits scale overflow-char padchar
exponent-char)
(setq args (nthcdr index args))
(if (null args)
(error "Not enough args for ~~E format directive"))
;; initialize defaults
(unless width (setq width -1))
(unless digits (setq digits 1))
(unless exp-digits (setq exp-digits 2))
(unless scale (setq scale 0))
(setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
(setq padchar (if padchar (int-char padchar) #\Space))
(setq exponent-char (if exponent-char (int-char exponent-char) #\E))
(print-float (car args) stream :exponential width digits
scale padchar atsign-modifier)
(1+ index)))
(%set-format-dispatch-func #\{
#'(lambda (stream args index atsign-modifier colon-modifier control)
(setq args (nthcdr index args))
(unless args
(error "Not enough args for ~~{ format directive"))
(unless (or (listp (car args)) atsign-modifier)
(error "Invalid format argument--should be a list"))
(let ((end-brace-index (search "~}" (car control) :start2 (cadr control)))
string)
(if end-brace-index
(setq string (subseq (car control) (cadr control) end-brace-index))
(error "Missing ~~} following ~{ in format string"))
(setf (cadr control) (+ 2 end-brace-index))
(cond
((and colon-modifier atsign-modifier)
(return
(do ((arg-index 0))
((>= arg-index (length args)) (+ index arg-index))
(%format-list stream string (nth arg-index args))
(incf arg-index))))
(colon-modifier
(return
(do ((arg-index 0))
((>= arg-index (length (car args))) (1+ index))
(%format-list stream string (nth arg-index (car args)))
(incf arg-index))))
(atsign-modifier
(return
(do ((arg-index 0))
((>= arg-index (length args)) (+ index arg-index))
(incf arg-index
(%format-list stream string (nthcdr arg-index args))))))
(t
(catch '%format-up-and-out
(do ((arg-index 0))
((>= arg-index (length (car args))) (1+ index))
(incf arg-index
(%format-list stream string
(nthcdr arg-index (car args))))))
(1+ index))))))
;; case conversion
(%set-format-dispatch-func #\(
#'(lambda (stream args index atsign-modifier colon-modifier control)
(setq args (nthcdr index args)) ;; skip unnecessary arguments
;; collect the characters up until a closing parentheses
(let ((close-paren-index (search "~)" (car control) :start2 (cadr control)))
string
(string-stream (make-string-output-stream)))
(if close-paren-index
(setq string (subseq (car control) (cadr control) close-paren-index))
(error "Missing ~~) following ~( in format string"))
(setf (cadr control) (+ 2 close-paren-index))
(setf index (%format-list string-stream string args))
(setq string (get-output-stream-string string-stream))
(cond
((and colon-modifier atsign-modifier)
(progn
(setq string (string-upcase string))
(write-string string stream)
(return index)))
(colon-modifier
(progn
(setq string (string-capitalize string))
(write-string string stream)
(return index)))
;; need to fix this to only capitalize the first word
(atsign-modifier
(progn
(setq string (string-capitalize string))
(write-string string stream)
(return index)))
(t
(progn
(setq string (string-downcase string))
(write-string string stream)
(return index)))))))
;; using the string between the ~[ and ~], return a list of the
;; control strings separated by ~;
(defun %expr-list (string)
(do ((size (length string))
(ret nil)
semicolon-index
new-string
(position 0))
((>= position size) (nreverse ret))
(setq semicolon-index (search "~;" string :start2 position))
(if (null semicolon-index)
(setq semicolon-index size))
(setq new-string (subseq string position semicolon-index))
(setq ret (cons new-string ret))
(setq position (+ semicolon-index 2))))
;; conditional expressions
(%set-format-dispatch-func #\[
#'(lambda (stream args index atsign-modifier colon-modifier control)
(setq args (nthcdr index args)) ;; skip unnecessary arguments
(if (null args)
(error "Not enough args for ~~[ format directive"))
;; collect the characters up until a closing brace
(let ((close-brace-index (search "~]" (car control) :start2 (cadr control)))
string
conditional-exprs
selector
(string-stream (make-string-output-stream)))
(if close-brace-index
(setq string (subseq (car control) (cadr control) close-brace-index))
(error "Missing ~~] following ~[ in format string"))
(setf (cadr control) (+ 2 close-brace-index))
(setf conditional-exprs (%expr-list string))
(setf selector (car args))
(setf args (cdr args))
(setf index (1+ index))
(cond
((and colon-modifier atsign-modifier)
(error "~:@[ not allowed in format control string"))
(atsign-modifier
(progn))
(colon-modifier
(let ((ctstring
(if selector (cadr conditional-exprs) (car conditional-exprs))))
(setf index (%format-list string-stream ctstring args))
(setq string (get-output-stream-string string-stream))
(write-string string stream)))
(t
(let ((ctstring (nth selector conditional-exprs)))
(setf index (%format-list string-stream ctstring args))
(setq string (get-output-stream-string string-stream))
(write-string string stream))))
index)))
(%set-format-dispatch-func #\^
#'(lambda (stream args index atsign-modifier colon-modifier control)
(setq args (nthcdr index args))
(unless args (throw '%format-up-and-out nil))
index))
(%set-format-dispatch-func #\&
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional num)
(unless num (setq num 1))
(if (>= num 1)
(progn
(fresh-line stream)
(dotimes (i (1- num))
(terpri stream))))
index))
(%set-format-dispatch-func #\|
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional num)
(unless num (setq num 1))
(dotimes (i num)
(write-char (int-char 12) stream))
index))
(%set-format-dispatch-func #\Newline
#'(lambda (stream args index atsign-modifier colon-modifier control)
;; if atsign, process the newline
(if atsign-modifier
(terpri stream))
;; skip whitespace
(unless colon-modifier
(do ((c (char (car control) (cadr control))
(char (car control) (cadr control))))
((not (or (char= c #\Space) (char= c #\Tab))))
(incf (cadr control)))
index)))
(%set-format-dispatch-func #\T
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional colnum colinc)
(unless colnum (setq colnum 1))
(unless colinc (setq colinc 1))
(if atsign-modifier
(progn
(dotimes (i colnum)
(write-char #\Space stream))
(dotimes (i (- colinc (mod (stream-column stream) colinc)))
(write-char #\Space stream)))
(let ((current-position (stream-column stream)))
(if (> colnum current-position)
(dotimes (i (- colnum current-position))
(write-char #\Space stream))
(if (> colinc 0)
(dotimes (i (- colinc (mod (- current-position colnum) colinc)))
(write-char #\Space stream))))))
index))
(%set-format-dispatch-func #\*
#'(lambda (stream args index atsign-modifier colon-modifier control
&optional num)
(unless num (if atsign-modifier (setq num 0) (setq num 1)))
(if atsign-modifier
(return num))
(if colon-modifier (return (- index num)))
(return (+ index num))))
(defun %format-integer (stream int radix atsign-modifier colon-modifier
mincol padchar commachar)
;; initialize defaults
(unless mincol (setq mincol 0))
(setq padchar (if padchar (int-char padchar) #\Space))
(setq commachar (if commachar (int-char commachar) #\,))
(let ((*print-base* radix)
(*print-radix* nil)
s
(length 0)
sign)
(if (and atsign-modifier (plusp int))
(progn (setf sign #\+) (incf length))
(if (minusp int)
(progn (setf sign #\-) (incf length) (setf int (- int)))))
(setq s (with-output-to-string (x) (princ int x)))
(incf length (length s))
(if colon-modifier
(incf length (truncate (1- (length s)) 3)))
(if (< length mincol)
(dotimes (i (- mincol length))
(write-char padchar stream)))
(if sign (write-char sign stream))
(if colon-modifier
(dotimes (i (length s))
(write-char (char s i) stream)
(let* ((digits-left (- (length s) (1+ i)))
(digit-pos (mod digits-left 3)))
(if (and (zerop digit-pos) (plusp digits-left))
(write-char commachar stream))))
(princ s stream))))
(defconstant *format-cardinals*
#("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten"
"twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety" "hundred"
"thousand" "million" "billion" "trillion"))
(defun %format-cardinal-number (int stream)
(if (zerop int) (return (princ "zero" stream)))
(if (minusp int)
(progn (princ "negative " stream) (setq int (- int))))
(cond
((< int 20)
(princ (nth int '("zero" "one" "two" "three" "four" "five"
"six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
"fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
stream))
((< int 100)
(princ (nth (- (truncate int 10) 2) '("twenty" "thirty" "forty"
"fifty" "sixty" "seventy" "eighty" "ninety")) stream)
(if (plusp (mod int 10))
(progn
(write-char #\- stream)
(%format-cardinal-number (mod int 10) stream))))
((< int 1000)
(%format-cardinal-number (truncate int 100) stream)
(princ " hundred" stream)
(if (plusp (mod int 100))
(progn
(write-char #\Space stream)
(%format-cardinal-number (mod int 100) stream))))
((< int 1000000)
(%format-cardinal-number (truncate int 1000) stream)
(princ " thousand" stream)
(if (plusp (mod int 1000))
(progn
(write-char #\Space stream)
(%format-cardinal-number (mod int 1000) stream))))
((< int 1000000000)
(%format-cardinal-number (truncate int 1000000) stream)
(princ " million" stream)
(if (plusp (mod int 1000000))
(progn
(write-char #\Space stream)
(%format-cardinal-number (mod int 1000000) stream))))
(t (princ "billions"))))
(defun %format-ordinal-number (int stream)
(princ "Sorry" stream))
(defun %format-roman-numeral (int stream)
(princ "Sorry" stream))
(defun %format-old-roman-numeral (int stream)
(princ "Sorry" stream))